Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/P4⁄Mac 2.0d4/Mac source 2.0/pcom1.p

Text File | 1996-09-28 | 27.4 KB | 1,202 lines | [TEXT/CWIE]

{P4/Mac port by Ingemar Ragenamlm 1994-1996}

unit pcom1;
interface
    uses
        Messages;

    const
        displimit = 20;
        maxlevel = 10;
        intsize = 1;
        intal = 1;
        realsize = 1;
        realal = 1;
        charsize = 1;
        charal = 1;
        charmax = 1;
        boolsize = 1;
        boolal = 1;
        ptrsize = 1;
        adral = 1;
        setsize = 1;
        setal = 1;
        stackal = 1;
        stackelsize = 1;
        strglgth = 16;        {Max string length, 16 characters}
        sethigh = 47;
        setlow = 0;
        ordmaxchar = 63;
        ordminchar = 0;
        maxint = 32767;
        lcaftermarkstack = 5;
        fileal = charal;
   (* stackelsize = minimum size for 1 stackelement}
{          = k*stackal}
{      stackal     = scm(all other al-constants)}
{      charmax     = scm(charsize,charal)}
{            scm = smallest common multiple}
{      lcaftermarkstack >= 4*ptrsize+max(x-size)}
{            = k1*stackelsize      *)
        maxstack = 1;
        parmal = stackal;
        parmsize = stackelsize;
        recal = stackal;
        filebuffer = 4;
        maxaddr = maxint;



    type                            (*describing:*)
                                (*************)

        marktype = ^integer;
                                (*basic symbols*)
                                (***************)

        p_symbol = (ident, intconst, realconst, stringconst, notsy, mulop, addop, relop, lparent, rparent, lbrack, rbrack, comma, semicolon, period, arrow, colon, becomes, labelsy, constsy, typesy, varsy, funcsy, progsy, procsy, setsy, packedsy, arraysy, recordsy, filesy, forwardsy, beginsy, ifsy, casesy, repeatsy, whilesy, forsy, withsy, gotosy, endsy, elsesy, untilsy, ofsy, dosy, tosy, downtosy, thensy, othersy);
        operator = (mul, rdiv, andop, idiv, imod, plus, minus, orop, ltop, leop, geop, gtop, neop, eqop, inop, noop);
        setofsys = set of p_symbol;
        chtp = (letter, number, special, illegal, chstrquo, chcolon, chperiod, chlt, chgt, chlparen, chspace);

                                (*constants*)
                                (***********)
        setty = set of setlow..sethigh;
        cstclass = (reel, pset, strg);
        csp = ^constant;
        constant = record
                case cclass : cstclass of
                    reel: (
                            rval: packed array[1..strglgth] of char
                    );
                    pset: (
                            pval: setty
                    );
                    strg: (
                            slgth: 0..strglgth;
                            sval: packed array[1..strglgth] of char
                    )
            end;

        valu = record
                case intval : boolean of  (*intval never set nor tested*)
                    true: (
                            ival: integer
                    );
                    false: (
                            valp: csp
                    )
            end;

                               (*data structures*)
                               (*****************)
        levrange = 0..maxlevel;
        addrrange = 0..maxaddr;
        structform = (scalar, subrange, pointer, power, arrays, records, files, tagfld, variant);
        declkind = (standard, declared);
        stp = ^structure;
        ctp = ^identifier;

        structure = packed record
                marked: boolean;   (*for test phase only*)
                size: addrrange;
                case form : structform of
                    scalar: (
                            case scalkind : declkind of
                                declared: (
                                        fconst: ctp
                                );
                                standard: (
                                )
                    );
                    subrange: (
                            rangetype: stp;
                            min, max: valu
                    );
                    pointer: (
                            eltype: stp
                    );
                    power: (
                            elset: stp
                    );
                    arrays: (
                            aeltype, inxtype: stp
                    );
                    records: (
                            fstfld: ctp;
                            recvar: stp
                    );
                    files: (
                            filtype: stp
                    );
                    tagfld: (
                            tagfieldp: ctp;
                            fstvar: stp
                    );
                    variant: (
                            nxtvar, subvar: stp;
                            varval: valu
                    )
            end;

                                (*names*)
                                (*******)

        idclass = (types, konst, vars, field, proc, func);
        setofids = set of idclass;
        idkind = (actual, formal);
        alpha = packed array[1..8] of char;

        identifier = packed record
                name: alpha;
                llink, rlink: ctp;
                idtype: stp;
                next: ctp;
                case klass : idclass of
                    types: (
                    );
                    konst: (
                            values: valu
                    );
                    vars: (
                            vkind: idkind;
                            vlev: levrange;
                            vaddr: addrrange
                    );
                    field: (
                            fldaddr: addrrange
                    );
                    proc, func: (
                            case pfdeckind : declkind of
                                standard: (
                                        key: 1..15
                                );
                                declared: (
                                        pflev: levrange;
                                        pfname: integer;
                                        case pfkind : idkind of
                                            actual: (
                                                    forwdecl, externl: boolean
                                            );
                                            formal: (
                                            )
                                )
                    )
            end;


        disprange = 0..displimit;
        where = (blck, crec, vrec, rec);

                                (*expressions*)
                                (*************)
        attrkind = (cst, varbl, expr);
        vaccess = (drct, indrct, inxd);

        attr = record
                typtr: stp;
                case kind : attrkind of
                    cst: (
                            cval: valu
                    );
                    varbl: (
                            case access : vaccess of
                                drct: (
                                        vlevel: levrange;
                                        dplmt: addrrange
                                );
                                indrct: (
                                        idplmt: addrrange
                                )
                    )
            end;

        testp = ^testpointer;
        testpointer = packed record
                elt1, elt2: stp;
                lasttestp: testp
            end;

                                 (*labels*)
                                 (********)
        lbp = ^labl;
        labl = record
                nextlab: lbp;
                defined: boolean;
                labval, labname: integer
            end;

        extfilep = ^filerec;
        filerec = record
                filename: alpha;
                nextfile: extfilep
            end;

(*-------------------------------------------------------------------------*)

    var
        prr: text; (* comment this out when compiling with pcom *)
                    (*returned by source program scanner}
{                     insymbol:}
{                     **********)

        sy: p_symbol;             (*last symbol*)
        op: operator;           (*classification of last symbol*)
        val: valu;              (*value of last constant*)
        lgth: integer;          (*length of last string constant*)
        id: alpha;              (*last identifier (possibly truncated)*)
        kk: 1..8;               (*nr of chars in last identifier*)
        ch: char;               (*last character*)
        eol: boolean;           (*end of line flag*)


                    (*counters:*)
                    (***********)

        chcnt: integer;         (*character counter*)
        lc, ic: addrrange;           (*data location and instruction counter*)
        linecount: integer;


                    (*switches:*)
                    (***********)

        dp,                 (*declaration part*)
        prterr,             (*to allow forward references in pointer type}
{                      declaration by suppressing error message*)
        list, prcode, prtables: boolean;  (*output options for}
{                    -- source program listing}
{                    -- printing symbolic code}
{                    -- displaying ident and struct tables}
{                    --> procedure option*)
        debug: boolean;


                    (*pointers:*)
                    (***********)
        parmptr, intptr, realptr, charptr, boolptr, nilptr, textptr: stp;    (*pointers to entries of standard ids*)
        utypptr, ucstptr, uvarptr, ufldptr, uprcptr, ufctptr,    (*pointers to entries for undeclared ids*)
        fwptr: ctp;             (*head of chain of forw decl type ids*)
        fextfilep: extfilep;        (*head of chain of external files*)
        globtestp: testp;           (*last testpointer*)


                    (*bookkeeping of declaration levels:*)
                    (************************************)

        level: levrange;        (*current static level*)
        disx,               (*level of last id searched by searchid*)
        top: disprange;         (*top of display*)

        display:            (*where:   means:*)
        array[disprange] of packed record           (*=blck:   id is variable id*)
                fname: ctp;
                flabel: lbp;  (*=crec:   id is field id in record with*)
                case occur : where of      (*     constant address*)
                    crec: (
                            clev: levrange;  (*=vrec:   id is field id in record with*)
                            cdspl: addrrange
                    );(*     variable address*)
                    vrec: (
                            vdspl: addrrange
                    )
            end;              (* --> procedure withstatement*)


                    (*error messages:*)
                    (*****************)

        errinx: 0..10;          (*nr of errors in current source line*)
        errlist: array[1..10] of packed record
                pos: integer;
                nmr: 1..400
            end;



                    (*expression compilation:*)
                    (*************************)

        gattr: attr;            (*describes the expr currently compiled*)


                    (*structured constants:*)
                    (***********************)

        constbegsys, simptypebegsys, typebegsys, blockbegsys, selectsys, facbegsys, statbegsys, typedels: setofsys;
        chartp: array[char] of chtp;
        rw: array[1..35] of alpha;(*nr. of res. words*)
        frw: array[1..9] of 1..36;(*nr. of res. words + 1*)
        rsy: array[1..35] of p_symbol;(*nr. of res. words*)
        ssy: array[char] of p_symbol;
        rop: array[1..35] of operator;(*nr. of res. words*)
        sop: array[char] of operator;
        na: array[1..35] of alpha;
        mn: array[0..60] of packed array[1..4] of char;
        sna: array[1..23] of packed array[1..4] of char;
        cdx: array[0..60] of -4..+4;
        pdx: array[1..23] of -7..+7;
        ordint: array[char] of integer;

        intlabel, mxint10, digmax: integer;


    procedure mark (var p: marktype);
    procedure release (p: marktype);
    procedure endofline;
    procedure error (ferrnr: integer);
    procedure insymbol;
    procedure enterid (fcp: ctp);
    procedure searchsection (fcp: ctp; var fcp1: ctp);
    procedure searchid (fidcls: setofids; var fcp: ctp);
    procedure getbounds (fsp: stp; var fmin, fmax: integer);
    function alignquot (fsp: stp): integer;
    procedure align (fsp: stp; var flc: addrrange);
    procedure printtables (fb: boolean);
    procedure genlabel (var nxtlab: integer);



implementation

(*-------------------------------------------------------------------------*)
    procedure mark (var p: marktype);
    begin
    end;
    procedure release (p: marktype);
    begin
    end;

    procedure endofline;
        var
            lastpos, freepos, currpos, currnmr, f, k: integer;
    begin
        if errinx > 0 then   (*output error messages*)
            begin
                WriteMessage(StringOf(linecount : 6, ' ****  ' : 9));
                lastpos := 0;
                freepos := 1;
                for k := 1 to errinx do
                    begin
                        with errlist[k] do
                            begin
                                currpos := pos;
                                currnmr := nmr
                            end;
                        if currpos = lastpos then
                            WriteMessage(',')
                        else
                            begin
                                while freepos < currpos do
                                    begin
                                        WriteMessage(' ');
                                        freepos := freepos + 1
                                    end;
                                WriteMessage('^');
                                lastpos := currpos
                            end;
                        if currnmr < 10 then
                            f := 1
                        else if currnmr < 100 then
                            f := 2
                        else
                            f := 3;
                        WriteMessage(StringOf(currnmr : f));
                        freepos := freepos + f + 1
                    end;
                WriteLnMessage;
                errinx := 0
            end;
        linecount := linecount + 1;
        if list and (not eof(input)) then
            begin
                WriteMessage(StringOf(linecount : 6, '  ' : 2));
                if dp then
                    WriteMessage(StringOf(lc : 7))
                else
                    WriteMessage(StringOf(ic : 7));
                WriteMessage(' ')
            end;
        chcnt := 0
    end;  (*endofline*)

    procedure error (ferrnr: integer);
    begin
        if errinx >= 9 then
            begin
                errlist[10].nmr := 255;
                errinx := 10
            end
        else
            begin
                errinx := errinx + 1;
                errlist[errinx].nmr := ferrnr
            end;
        errlist[errinx].pos := chcnt
    end; (*error*)

    procedure insymbol;
    (*read next basic symbol of source program and return its}
{    description in the global variables sy, op, id, val and lgth*)
        label
            1, 2, 3;
        var
            i, k: integer;
            digit: packed array[1..strglgth] of char;
            aString: packed array[1..strglgth] of char;
            lvp: csp;
            test: boolean;

        procedure nextch;
        begin
            if eol then
                begin
                    if list then
                        WriteLnMessage;
                    endofline
                end;
            if not eof(input) then
                begin
                    eol := eoln(input);
                    read(input, ch);
                    if list then
                        WriteMessage(ch);
                    chcnt := chcnt + 1
                end
            else
                begin
                    WriteMessageLine(StringOf('   *** eof ', 'encountered'));
                    test := false
                end
        end;

        procedure options;
        begin
            repeat
                nextch;
                if ch <> '*' then
                    begin
                        if ch = 't' then
                            begin
                                nextch;
                                prtables := ch = '+'
                            end
                        else if ch = 'l' then
                            begin
                                nextch;
                                list := ch = '+';
                                if not list then
                                    WriteLnMessage
                            end
                        else if ch = 'd' then
                            begin
                                nextch;
                                debug := ch = '+'
                            end
                        else if ch = 'c' then
                            begin
                                nextch;
                                prcode := ch = '+'
                            end;
                        nextch
                    end
            until ch <> ','
        end; (*options*)

    begin (*insymbol*)
1:
        repeat
            while ((ch = ' ') or (ch = '    ')) and not eol do
                nextch;
            test := eol;
            if test then
                nextch
        until not test;
        if chartp[ch] = illegal then
            begin
                sy := othersy;
                op := noop;
                error(399);
                nextch
            end
        else
            case chartp[ch] of
                letter:
                    begin
                        k := 0;
                        repeat
                            if k < 8 then
                                begin
                                    k := k + 1;
                                    id[k] := ch
                                end;
                            nextch
                        until chartp[ch] in [special, illegal, chstrquo, chcolon, chperiod, chlt, chgt, chlparen, chspace];
                        if k >= kk then
                            kk := k
                        else
                            repeat
                                id[kk] := ' ';
                                kk := kk - 1
                            until kk = k;
                        for i := frw[k] to frw[k + 1] - 1 do
                            if rw[i] = id then
                                begin
                                    sy := rsy[i];
                                    op := rop[i];
                                    goto 2
                                end;
                        sy := ident;
                        op := noop;
2:
                    end;
                number:
                    begin
                        op := noop;
                        i := 0;
                        repeat
                            i := i + 1;
                            if i <= digmax then
                                digit[i] := ch;
                            nextch
                        until chartp[ch] <> number;
                        if ((ch = '.') and (input^ <> '.')) or (ch = 'e') then
                            begin
                                k := i;
                                if ch = '.' then
                                    begin
                                        k := k + 1;
                                        if k <= digmax then
                                            digit[k] := ch;
                                        nextch; (*if ch = '.' then begin ch := ':'; goto 3 end;*)
                                        if chartp[ch] <> number then
                                            error(201)
                                        else
                                            repeat
                                                k := k + 1;
                                                if k <= digmax then
                                                    digit[k] := ch;
                                                nextch
                                            until chartp[ch] <> number
                                    end;
                                if ch = 'e' then
                                    begin
                                        k := k + 1;
                                        if k <= digmax then
                                            digit[k] := ch;
                                        nextch;
                                        if (ch = '+') or (ch = '-') then
                                            begin
                                                k := k + 1;
                                                if k <= digmax then
                                                    digit[k] := ch;
                                                nextch
                                            end;
                                        if chartp[ch] <> number then
                                            error(201)
                                        else
                                            repeat
                                                k := k + 1;
                                                if k <= digmax then
                                                    digit[k] := ch;
                                                nextch
                                            until chartp[ch] <> number
                                    end;
                                new(lvp, reel);
                                sy := realconst;
                                lvp^.cclass := reel;
                                with lvp^ do
                                    begin
                                        for i := 1 to strglgth do
                                            rval[i] := ' ';
                                        if k <= digmax then
                                            for i := 2 to k + 1 do
                                                rval[i] := digit[i - 1]
                                        else
                                            begin
                                                error(203);
                                                rval[2] := '0';
                                                rval[3] := '.';
                                                rval[4] := '0'
                                            end
                                    end;
                                val.valp := lvp
                            end
                        else
3:
                            begin
                                if i > digmax then
                                    begin
                                        error(203);
                                        val.ival := 0
                                    end
                                else
                                    with val do
                                        begin
                                            ival := 0;
                                            for k := 1 to i do
                                                begin
                                                    if ival <= mxint10 then
                                                        ival := ival * 10 + ordint[digit[k]]
                                                    else
                                                        begin
                                                            error(203);
                                                            ival := 0
                                                        end
                                                end;
                                            sy := intconst
                                        end
                            end
                    end;
                chstrquo:
                    begin
                        lgth := 0;
                        sy := stringconst;
                        op := noop;
                        repeat
                            repeat
                                nextch;
                                lgth := lgth + 1;
                                if lgth <= strglgth then
                                    aString[lgth] := ch
                            until (eol) or (ch = '''');
                            if eol then
                                error(202)
                            else
                                nextch
                        until ch <> '''';
                        lgth := lgth - 1;   (*now lgth = nr of chars in aString*)
                        if lgth = 0 then
                            error(205)
                        else if lgth = 1 then
                            val.ival := ord(aString[1])
                        else
                            begin
                                new(lvp, strg);
                                lvp^.cclass := strg;
                                if lgth > strglgth then
                                    begin
                                        error(399);
                                        lgth := strglgth
                                    end;
                                with lvp^ do
                                    begin
                                        slgth := lgth;
                                        for i := 1 to lgth do
                                            sval[i] := aString[i]
                                    end;
                                val.valp := lvp
                            end
                    end;
                chcolon:
                    begin
                        op := noop;
                        nextch;
                        if ch = '=' then
                            begin
                                sy := becomes;
                                nextch
                            end
                        else
                            sy := colon
                    end;
                chperiod:
                    begin
                        op := noop;
                        nextch;
                        if ch = '.' then
                            begin
                                sy := colon;
                                nextch
                            end
                        else
                            sy := period
                    end;
                chlt:
                    begin
                        nextch;
                        sy := relop;
                        if ch = '=' then
                            begin
                                op := leop;
                                nextch
                            end
                        else if ch = '>' then
                            begin
                                op := neop;
                                nextch
                            end
                        else
                            op := ltop
                    end;
                chgt:
                    begin
                        nextch;
                        sy := relop;
                        if ch = '=' then
                            begin
                                op := geop;
                                nextch
                            end
                        else
                            op := gtop
                    end;
                chlparen:
                    begin
                        nextch;
                        if ch = '*' then
                            begin
                                nextch;
                                if ch = '$' then
                                    options;
                                repeat
                                    while (ch <> '*') and not eof(input) do
                                        nextch;
                                    nextch
                                until (ch = ')') or eof(input);
                                nextch;
                                goto 1
                            end;
                        sy := lparent;
                        op := noop
                    end;
                special:
                    begin
                        sy := ssy[ch];
                        op := sop[ch];
                        nextch
                    end;
                chspace:
                    sy := othersy
            end (*case*)
    end; (*insymbol*)

    procedure enterid (fcp: ctp);
    (*enter id pointed at by fcp into the name-table,}
{     which on each declaration level is organised as}
{     an unbalanced binary tree*)
        var
            nam: alpha;
            lcp, lcp1: ctp;
            lleft: boolean;
    begin
        nam := fcp^.name;
        lcp := display[top].fname;
        if lcp = nil then
            display[top].fname := fcp
        else
            begin
                repeat
                    lcp1 := lcp;
                    if lcp^.name = nam then   (*name conflict, follow right link*)
                        begin
                            error(101);
                            lcp := lcp^.rlink;
                            lleft := false
                        end
                    else if lcp^.name < nam then
                        begin
                            lcp := lcp^.rlink;
                            lleft := false
                        end
                    else
                        begin
                            lcp := lcp^.llink;
                            lleft := true
                        end
                until lcp = nil;
                if lleft then
                    lcp1^.llink := fcp
                else
                    lcp1^.rlink := fcp
            end;
        fcp^.llink := nil;
        fcp^.rlink := nil
    end; (*enterid*)

    procedure searchsection (fcp: ctp; var fcp1: ctp);
    (*to find record fields and forward declared procedure id's}
{     --> procedure proceduredeclaration}
{     --> procedure selector*)
        label
            1;
    begin
        while fcp <> nil do
            if fcp^.name = id then
                goto 1
            else if fcp^.name < id then
                fcp := fcp^.rlink
            else
                fcp := fcp^.llink;
1:
        fcp1 := fcp
    end; (*searchsection*)

    procedure searchid (fidcls: setofids; var fcp: ctp);
        label
            1;
        var
            lcp: ctp;
            localDisx: disprange; {Must have a local variable for "for"; disx is assigned once we leave the loop}
    begin
        for localDisx := top downto 0 do
            begin
                lcp := display[localDisx].fname;
                while lcp <> nil do
                    if lcp^.name = id then
                        if lcp^.klass in fidcls then
                            goto 1
                        else
                            begin
                                if prterr then
                                    error(103);
                                lcp := lcp^.rlink
                            end
                    else if lcp^.name < id then
                        lcp := lcp^.rlink
                    else
                        lcp := lcp^.llink
            end;
    (*search not successful; suppress error message in case}
{     of forward referenced type id in pointer type definition}
{     --> procedure simpletype*)
        if prterr then
            begin
                error(104);
    (*to avoid returning nil, reference an entry}
{     for an undeclared id of appropriate class}
{     --> procedure enterundecl*)
                if types in fidcls then
                    lcp := utypptr
                else if vars in fidcls then
                    lcp := uvarptr
                else if field in fidcls then
                    lcp := ufldptr
                else if konst in fidcls then
                    lcp := ucstptr
                else if proc in fidcls then
                    lcp := uprcptr
                else
                    lcp := ufctptr;
            end;
1:
        disx := localDisx; {Export local var for loop}
        fcp := lcp
    end; (*searchid*)

    procedure getbounds (fsp: stp; var fmin, fmax: integer);
    (*get internal bounds of subrange or scalar type*)
    (*assume fsp<>intptr and fsp<>realptr*)
    begin
        fmin := 0;
        fmax := 0;
        if fsp <> nil then
            with fsp^ do
                if form = subrange then
                    begin
                        fmin := min.ival;
                        fmax := max.ival
                    end
                else if fsp = charptr then
                    begin
                        fmin := ordminchar;
                        fmax := ordmaxchar
                    end
                else if fconst <> nil then
                    fmax := fconst^.values.ival
    end; (*getbounds*)

    function alignquot (fsp: stp): integer;
    begin
        alignquot := 1;
        if fsp <> nil then
            with fsp^ do
                case form of
                    scalar:
                        if fsp = intptr then
                            alignquot := intal
                        else if fsp = boolptr then
                            alignquot := boolal
                        else if scalkind = declared then
                            alignquot := intal
                        else if fsp = charptr then
                            alignquot := charal
                        else if fsp = realptr then
                            alignquot := realal
                        else (*parmptr*)
                            alignquot := parmal;
                    subrange:
                        alignquot := alignquot(rangetype);
                    pointer:
                        alignquot := adral;
                    power:
                        alignquot := setal;
                    files:
                        alignquot := fileal;
                    arrays:
                        alignquot := alignquot(aeltype);
                    records:
                        alignquot := recal;
                    variant, tagfld:
                        error(501)
                end
    end; (*alignquot*)

    procedure align (fsp: stp; var flc: addrrange);
        var
            k, l: integer;
    begin
        k := alignquot(fsp);
        l := flc - 1;
        flc := l + k - (k + l) mod k
    end; (*align*)

    procedure printtables (fb: boolean);
    (*print data structure and name table*)
        var
            i, lim: disprange;

        procedure marker;
      (*mark data structure entries to avoid multiple printout*)
            var
                i: integer;

            procedure markctp (fp: ctp);
            forward;

            procedure markstp (fp: stp);
    (*mark data structures, prevent cycles*)
            begin
                if fp <> nil then
                    with fp^ do
                        begin
                            marked := true;
                            case form of
                                scalar:
                                    ;
                                subrange:
                                    markstp(rangetype);
                                pointer:
                                    ;  (*don't mark eltype: cycle possible; will be marked}
{            anyway, if fp = true*)
                                power:
                                    markstp(elset);
                                arrays:
                                    begin
                                        markstp(aeltype);
                                        markstp(inxtype)
                                    end;
                                records:
                                    begin
                                        markctp(fstfld);
                                        markstp(recvar)
                                    end;
                                files:
                                    markstp(filtype);
                                tagfld:
                                    markstp(fstvar);
                                variant:
                                    begin
                                        markstp(nxtvar);
                                        markstp(subvar)
                                    end
                            end (*case*)
                        end (*with*)
            end; (*markstp*)

            procedure markctp;
            begin
                if fp <> nil then
                    with fp^ do
                        begin
                            markctp(llink);
                            markctp(rlink);
                            markstp(idtype)
                        end
            end; (*markctp*)

        begin (*marker*)
            for i := top downto lim do
                markctp(display[i].fname)
        end; (*marker*)

        procedure followctp (fp: ctp);
        forward;

        procedure followstp (fp: stp);
        begin
            if fp <> nil then
                with fp^ do
                    if marked then
                        begin
                            marked := false;
                            WriteMessage(StringOf(' ' : 4, ord(fp) : 6, size : 10));
                            case form of
                                scalar:
                                    begin
                                        WriteMessage(StringOf('scalar' : 10));
                                        if scalkind = standard then
                                            WriteMessage(StringOf('standard' : 10))
                                        else
                                            WriteMessage(StringOf('declared' : 10, ' ' : 4, ord(fconst) : 6));
                                        WriteLnMessage
                                    end;
                                subrange:
                                    begin
                                        WriteMessage(StringOf('subrange' : 10, ' ' : 4, ord(rangetype) : 6));
                                        if rangetype <> realptr then
                                            WriteMessage(StringOf(min.ival, max.ival))
                                        else if (min.valp <> nil) and (max.valp <> nil) then
                                            WriteMessage(StringOf(' ', min.valp^.rval : 9, ' ', max.valp^.rval : 9));
                                        WriteLnMessage;
                                        followstp(rangetype);
                                    end;
                                pointer:
                                    WriteMessageLine(StringOf('pointer' : 10, ' ' : 4, ord(eltype) : 6));
                                power:
                                    begin
                                        WriteMessageLine(StringOf('set' : 10, ' ' : 4, ord(elset) : 6));
                                        followstp(elset)
                                    end;
                                arrays:
                                    begin
                                        WriteMessageLine(StringOf('array' : 10, ' ' : 4, ord(aeltype) : 6, ' ' : 4, ord(inxtype) : 6));
                                        followstp(aeltype);
                                        followstp(inxtype)
                                    end;
                                records:
                                    begin
                                        WriteMessageLine(StringOf('record' : 10, ' ' : 4, ord(fstfld) : 6, ' ' : 4, ord(recvar) : 6));
                                        followctp(fstfld);
                                        followstp(recvar)
                                    end;
                                files:
                                    begin
                                        WriteMessage(StringOf('file' : 10, ' ' : 4, ord(filtype) : 6));
                                        followstp(filtype)
                                    end;
                                tagfld:
                                    begin
                                        WriteMessageLine(StringOf('tagfld' : 10, ' ' : 4, ord(tagfieldp) : 6, ' ' : 4, ord(fstvar) : 6));
                                        followstp(fstvar)
                                    end;
                                variant:
                                    begin
                                        WriteMessageLine(StringOf('variant' : 10, ' ' : 4, ord(nxtvar) : 6, ' ' : 4, ord(subvar) : 6, varval.ival));
                                        followstp(nxtvar);
                                        followstp(subvar)
                                    end
                            end (*case*)
                        end (*if marked*)
        end; (*followstp*)

        procedure followctp;
            var
                i: integer;
        begin
            if fp <> nil then
                with fp^ do
                    begin
                        WriteMessage(StringOf(' ' : 4, ord(fp) : 6, ' ', name : 9, ' ' : 4, ord(llink) : 6, ' ' : 4, ord(rlink) : 6, ' ' : 4, ord(idtype) : 6));
                        case klass of
                            types:
                                WriteMessage(StringOf('type' : 10));
                            konst:
                                begin
                                    WriteMessage(StringOf('constant' : 10, ' ' : 4, ord(next) : 6));
                                    if idtype <> nil then
                                        if idtype = realptr then
                                            begin
                                                if values.valp <> nil then
                                                    WriteMessage(StringOf(' ', values.valp^.rval : 9))
                                            end
                                        else if idtype^.form = arrays then  (*stringconst*)
                                            begin
                                                if values.valp <> nil then
                                                    begin
                                                        WriteMessage(' ');
                                                        with values.valp^ do
                                                            for i := 1 to slgth do
                                                                WriteMessage(StringOf(sval[i]))
                                                    end
                                            end
                                        else
                                            WriteMessage(StringOf(values.ival))
                                end;
                            vars:
                                begin
                                    WriteMessage(StringOf('variable' : 10));
                                    if vkind = actual then
                                        WriteMessage(StringOf('actual' : 10))
                                    else
                                        WriteMessage(StringOf('formal' : 10));
                                    WriteMessage(StringOf(' ' : 4, ord(next) : 6, vlev, ' ' : 4, vaddr : 6));
                                end;
                            field:
                                WriteMessage(StringOf('field' : 10, ' ' : 4, ord(next) : 6, ' ' : 4, fldaddr : 6));
                            proc, func:
                                begin
                                    if klass = proc then
                                        WriteMessage(StringOf('procedure' : 10))
                                    else
                                        WriteMessage(StringOf('function' : 10));
                                    if pfdeckind = standard then
                                        WriteMessage(StringOf('standard' : 10, key : 10))
                                    else
                                        begin
                                            WriteMessage(StringOf('declared' : 10, ' ' : 4, ord(next) : 6));
                                            WriteMessage(StringOf(pflev, ' ' : 4, pfname : 6));
                                            if pfkind = actual then
                                                begin
                                                    WriteMessage(StringOf('actual' : 10));
                                                    if forwdecl then
                                                        WriteMessage(StringOf('forward' : 10))
                                                    else
                                                        WriteMessage(StringOf('notforward' : 10));
                                                    if externl then
                                                        WriteMessage(StringOf('extern' : 10))
                                                    else
                                                        WriteMessage(StringOf('not extern' : 10));
                                                end
                                            else
                                                WriteMessage(StringOf('formal' : 10))
                                        end
                                end
                        end; (*case*)
                        WriteLnMessage;
                        followctp(llink);
                        followctp(rlink);
                        followstp(idtype)
                    end (*with*)
        end; (*followctp*)

    begin (*printtables*)
        WriteLnMessage;
        WriteLnMessage;
        WriteLnMessage;
        if fb then
            lim := 0
        else
            begin
                lim := top;
                WriteMessage(' local')
            end;
        WriteMessageLine(' tables ');
        WriteLnMessage;
        marker;
        for i := top downto lim do
            followctp(display[i].fname);
        WriteLnMessage;
        if not eol then
            WriteMessage(StringOf(' ' : chcnt + 16))
    end; (*printtables*)

    procedure genlabel (var nxtlab: integer);
    begin
        intlabel := intlabel + 1;
        nxtlab := intlabel
    end; (*genlabel*)



end.